home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / generic / tclMain.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  9.3 KB  |  341 lines  |  [TEXT/CWIE]
  1. /* 
  2.  * tclMain.c --
  3.  *
  4.  *    Main program for Tcl shells and other Tcl-based applications.
  5.  *
  6.  * Copyright (c) 1988-1994 The Regents of the University of California.
  7.  * Copyright (c) 1994-1996 Sun Microsystems, Inc.
  8.  *
  9.  * See the file "license.terms" for information on usage and redistribution
  10.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11.  *
  12.  * SCCS: @(#) tclMain.c 1.54 97/08/07 19:04:43
  13.  */
  14.  
  15. #include "tcl.h"
  16. #include "tclInt.h"
  17.  
  18. /*
  19.  * The following code ensures that tclLink.c is linked whenever
  20.  * Tcl is linked.  Without this code there's no reference to the
  21.  * code in that file from anywhere in Tcl, so it may not be
  22.  * linked into the application.
  23.  */
  24.  
  25. EXTERN int Tcl_LinkVar();
  26. int (*tclDummyLinkVarPtr)() = Tcl_LinkVar;
  27.  
  28. /*
  29.  * Declarations for various library procedures and variables (don't want
  30.  * to include tclPort.h here, because people might copy this file out of
  31.  * the Tcl source directory to make their own modified versions).
  32.  * Note:  "exit" should really be declared here, but there's no way to
  33.  * declare it without causing conflicts with other definitions elsewher
  34.  * on some systems, so it's better just to leave it out.
  35.  */
  36.  
  37. extern int        isatty _ANSI_ARGS_((int fd));
  38. extern char *        strcpy _ANSI_ARGS_((char *dst, CONST char *src));
  39.  
  40. static Tcl_Interp *interp;    /* Interpreter for application. */
  41.  
  42. #ifdef TCL_MEM_DEBUG
  43. static char dumpFile[100];    /* Records where to dump memory allocation
  44.                  * information. */
  45. static int quitFlag = 0;    /* 1 means "checkmem" command was called,
  46.                  * so the application should quit and dump
  47.                  * memory allocation information. */
  48. #endif
  49.  
  50. /*
  51.  * Forward references for procedures defined later in this file:
  52.  */
  53.  
  54. #ifdef TCL_MEM_DEBUG
  55. static int        CheckmemCmd _ANSI_ARGS_((ClientData clientData,
  56.                 Tcl_Interp *interp, int argc, char *argv[]));
  57. #endif
  58.  
  59. /*
  60.  *----------------------------------------------------------------------
  61.  *
  62.  * Tcl_Main --
  63.  *
  64.  *    Main program for tclsh and most other Tcl-based applications.
  65.  *
  66.  * Results:
  67.  *    None. This procedure never returns (it exits the process when
  68.  *    it's done.
  69.  *
  70.  * Side effects:
  71.  *    This procedure initializes the Tk world and then starts
  72.  *    interpreting commands;  almost anything could happen, depending
  73.  *    on the script being interpreted.
  74.  *
  75.  *----------------------------------------------------------------------
  76.  */
  77.  
  78. void
  79. Tcl_Main(argc, argv, appInitProc)
  80.     int argc;            /* Number of arguments. */
  81.     char **argv;        /* Array of argument strings. */
  82.     Tcl_AppInitProc *appInitProc;
  83.                 /* Application-specific initialization
  84.                  * procedure to call after most
  85.                  * initialization but before starting to
  86.                  * execute commands. */
  87. {
  88.     Tcl_Obj *prompt1NamePtr = NULL;
  89.     Tcl_Obj *prompt2NamePtr = NULL;
  90.     Tcl_Obj *resultPtr;
  91.     Tcl_Obj *commandPtr = NULL;
  92.     char buffer[1000], *args, *fileName, *bytes;
  93.     int code, gotPartial, tty, length;
  94.     int exitCode = 0;
  95.     Tcl_Channel inChannel, outChannel, errChannel;
  96.  
  97.     Tcl_FindExecutable(argv[0]);
  98.     interp = Tcl_CreateInterp();
  99. #ifdef TCL_MEM_DEBUG
  100.     Tcl_InitMemory(interp);
  101.     Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
  102.         (Tcl_CmdDeleteProc *) NULL);
  103. #endif
  104.  
  105.     /*
  106.      * Make command-line arguments available in the Tcl variables "argc"
  107.      * and "argv".  If the first argument doesn't start with a "-" then
  108.      * strip it off and use it as the name of a script file to process.
  109.      */
  110.  
  111.     fileName = NULL;
  112.     if ((argc > 1) && (argv[1][0] != '-')) {
  113.     fileName = argv[1];
  114.     argc--;
  115.     argv++;
  116.     }
  117.     args = Tcl_Merge(argc-1, argv+1);
  118.     Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
  119.     ckfree(args);
  120.     TclFormatInt(buffer, argc-1);
  121.     Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);
  122.     Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0],
  123.         TCL_GLOBAL_ONLY);
  124.  
  125.     /*
  126.      * Set the "tcl_interactive" variable.
  127.      */
  128.  
  129.     tty = isatty(0);
  130.     Tcl_SetVar(interp, "tcl_interactive",
  131.         ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY);
  132.     
  133.     /*
  134.      * Invoke application-specific initialization.
  135.      */
  136.  
  137.     if ((*appInitProc)(interp) != TCL_OK) {
  138.     errChannel = Tcl_GetStdChannel(TCL_STDERR);
  139.     if (errChannel) {
  140.         Tcl_Write(errChannel,
  141.             "application-specific initialization failed: ", -1);
  142.         Tcl_Write(errChannel, interp->result, -1);
  143.         Tcl_Write(errChannel, "\n", 1);
  144.     }
  145.     }
  146.  
  147.     /*
  148.      * If a script file was specified then just source that file
  149.      * and quit.
  150.      */
  151.  
  152.     if (fileName != NULL) {
  153.     code = Tcl_EvalFile(interp, fileName);
  154.     if (code != TCL_OK) {
  155.         errChannel = Tcl_GetStdChannel(TCL_STDERR);
  156.         if (errChannel) {
  157.         /*
  158.          * The following statement guarantees that the errorInfo
  159.          * variable is set properly.
  160.          */
  161.  
  162.         Tcl_AddErrorInfo(interp, "");
  163.         Tcl_Write(errChannel,
  164.             Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY), -1);
  165.         Tcl_Write(errChannel, "\n", 1);
  166.         }
  167.         exitCode = 1;
  168.     }
  169.     goto done;
  170.     }
  171.  
  172.     /*
  173.      * We're running interactively.  Source a user-specific startup
  174.      * file if the application specified one and if the file exists.
  175.      */
  176.  
  177.     Tcl_SourceRCFile(interp);
  178.  
  179.     /*
  180.      * Process commands from stdin until there's an end-of-file.  Note
  181.      * that we need to fetch the standard channels again after every
  182.      * eval, since they may have been changed.
  183.      */
  184.  
  185.     commandPtr = Tcl_NewObj();
  186.     Tcl_IncrRefCount(commandPtr);
  187.     prompt1NamePtr = Tcl_NewStringObj("tcl_prompt1", -1);
  188.     Tcl_IncrRefCount(prompt1NamePtr);
  189.     prompt2NamePtr = Tcl_NewStringObj("tcl_prompt2", -1);
  190.     Tcl_IncrRefCount(prompt2NamePtr);
  191.     
  192.     inChannel = Tcl_GetStdChannel(TCL_STDIN);
  193.     outChannel = Tcl_GetStdChannel(TCL_STDOUT);
  194.     gotPartial = 0;
  195.     while (1) {
  196.     if (tty) {
  197.         Tcl_Obj *promptCmdPtr;
  198.  
  199.         promptCmdPtr = Tcl_ObjGetVar2(interp,
  200.             (gotPartial? prompt2NamePtr : prompt1NamePtr),
  201.             (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
  202.         if (promptCmdPtr == NULL) {
  203.                 defaultPrompt:
  204.         if (!gotPartial && outChannel) {
  205.             Tcl_Write(outChannel, "% ", 2);
  206.         }
  207.         } else {
  208.         code = Tcl_EvalObj(interp, promptCmdPtr);
  209.         inChannel = Tcl_GetStdChannel(TCL_STDIN);
  210.         outChannel = Tcl_GetStdChannel(TCL_STDOUT);
  211.         errChannel = Tcl_GetStdChannel(TCL_STDERR);
  212.         if (code != TCL_OK) {
  213.             if (errChannel) {
  214.             resultPtr = Tcl_GetObjResult(interp);
  215.             bytes = Tcl_GetStringFromObj(resultPtr, &length);
  216.             Tcl_Write(errChannel, bytes, length);
  217.             Tcl_Write(errChannel, "\n", 1);
  218.             }
  219.             Tcl_AddErrorInfo(interp,
  220.                 "\n    (script that generates prompt)");
  221.             goto defaultPrompt;
  222.         }
  223.         }
  224.         if (outChannel) {
  225.         Tcl_Flush(outChannel);
  226.         }
  227.     }
  228.     if (!inChannel) {
  229.         goto done;
  230.     }
  231.         length = Tcl_GetsObj(inChannel, commandPtr);
  232.     if (length < 0) {
  233.         goto done;
  234.     }
  235.     if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) {
  236.         goto done;
  237.     }
  238.  
  239.         /*
  240.          * Add the newline removed by Tcl_GetsObj back to the string.
  241.          */
  242.  
  243.     Tcl_AppendToObj(commandPtr, "\n", 1);
  244.     if (!TclObjCommandComplete(commandPtr)) {
  245.         gotPartial = 1;
  246.         continue;
  247.     }
  248.  
  249.     gotPartial = 0;
  250.     code = Tcl_RecordAndEvalObj(interp, commandPtr, 0);
  251.     inChannel = Tcl_GetStdChannel(TCL_STDIN);
  252.     outChannel = Tcl_GetStdChannel(TCL_STDOUT);
  253.     errChannel = Tcl_GetStdChannel(TCL_STDERR);
  254.     Tcl_SetObjLength(commandPtr, 0);
  255.     if (code != TCL_OK) {
  256.         if (errChannel) {
  257.         resultPtr = Tcl_GetObjResult(interp);
  258.         bytes = Tcl_GetStringFromObj(resultPtr, &length);
  259.         Tcl_Write(errChannel, bytes, length);
  260.         Tcl_Write(errChannel, "\n", 1);
  261.         }
  262.     } else if (tty) {
  263.         resultPtr = Tcl_GetObjResult(interp);
  264.         bytes = Tcl_GetStringFromObj(resultPtr, &length);
  265.         if ((length > 0) && outChannel) {
  266.         Tcl_Write(outChannel, bytes, length);
  267.         Tcl_Write(outChannel, "\n", 1);
  268.         }
  269.     }
  270. #ifdef TCL_MEM_DEBUG
  271.     if (quitFlag) {
  272.         Tcl_DecrRefCount(commandPtr);
  273.         Tcl_DecrRefCount(prompt1NamePtr);
  274.         Tcl_DecrRefCount(prompt2NamePtr);
  275.         Tcl_DeleteInterp(interp);
  276.         Tcl_Exit(0);
  277.     }
  278. #endif
  279.     }
  280.  
  281.     /*
  282.      * Rather than calling exit, invoke the "exit" command so that
  283.      * users can replace "exit" with some other command to do additional
  284.      * cleanup on exit.  The Tcl_Eval call should never return.
  285.      */
  286.  
  287.     done:
  288.     if (commandPtr != NULL) {
  289.     Tcl_DecrRefCount(commandPtr);
  290.     }
  291.     if (prompt1NamePtr != NULL) {
  292.     Tcl_DecrRefCount(prompt1NamePtr);
  293.     }
  294.     if (prompt2NamePtr != NULL) {
  295.     Tcl_DecrRefCount(prompt2NamePtr);
  296.     }
  297.     sprintf(buffer, "exit %d", exitCode);
  298.     Tcl_Eval(interp, buffer);
  299. }
  300.  
  301. /*
  302.  *----------------------------------------------------------------------
  303.  *
  304.  * CheckmemCmd --
  305.  *
  306.  *    This is the command procedure for the "checkmem" command, which
  307.  *    causes the application to exit after printing information about
  308.  *    memory usage to the file passed to this command as its first
  309.  *    argument.
  310.  *
  311.  * Results:
  312.  *    Returns a standard Tcl completion code.
  313.  *
  314.  * Side effects:
  315.  *    None.
  316.  *
  317.  *----------------------------------------------------------------------
  318.  */
  319. #ifdef TCL_MEM_DEBUG
  320.  
  321.     /* ARGSUSED */
  322. static int
  323. CheckmemCmd(clientData, interp, argc, argv)
  324.     ClientData clientData;        /* Not used. */
  325.     Tcl_Interp *interp;            /* Interpreter for evaluation. */
  326.     int argc;                /* Number of arguments. */
  327.     char *argv[];            /* String values of arguments. */
  328. {
  329.     extern char *tclMemDumpFileName;
  330.     if (argc != 2) {
  331.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  332.         " fileName\"", (char *) NULL);
  333.     return TCL_ERROR;
  334.     }
  335.     strcpy(dumpFile, argv[1]);
  336.     tclMemDumpFileName = dumpFile;
  337.     quitFlag = 1;
  338.     return TCL_OK;
  339. }
  340. #endif
  341.